Manipulation Check
Real / Fake
# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
mutate(Participant = fct_relevel(Participant, df |>
group_by(Participant) |>
summarize(Belief_Answer = mean(Belief_Answer)) |>
ungroup() |>
arrange(Belief_Answer) |>
pull(Participant) |>
as.character())) |>
# mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
geom_vline(xintercept = 0, linetype = "dotted") +
scale_y_discrete(expand = c(0.02, 0)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-0.95, 0, 0.95),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d() +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "grey", color = "white") +
ggside::scale_xsidey_continuous(expand = c(0, 0))
df |>
group_by(Participant, Belief) |>
summarize(n = n() / 108,
Confidence = mean(Belief_Confidence)) |>
pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |>
ungroup() |>
describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
##
## Parameter | Mean | 95% CI
## -------------------------------------
## n_Fake | 0.44 | [0.11, 0.64]
## n_Real | 0.56 | [0.36, 0.89]
## Confidence_Fake | 0.61 | [0.24, 1.00]
## Confidence_Real | 0.61 | [0.25, 0.99]
m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.105
## Stimulus | 0.087
Colinearity
IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")
correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | r | 95% CI | t(10798) | p
## -----------------------------------------------------------------------
## Attractive | Beauty | 0.68 | [ 0.67, 0.69] | 97.16 | < .001***
## Attractive | Trustworthy | 0.06 | [ 0.04, 0.08] | 6.08 | < .001***
## Attractive | Familiar | 0.13 | [ 0.11, 0.15] | 13.35 | < .001***
## Beauty | Trustworthy | 0.26 | [ 0.24, 0.28] | 28.10 | < .001***
## Beauty | Familiar | 0.01 | [-0.01, 0.03] | 1.37 | 0.171
## Trustworthy | Familiar | 0.05 | [ 0.03, 0.06] | 4.80 | < .001***
##
## p-value adjustment method: Holm (1979)
## Observations: 10800
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
for (y in IVs) {
if (x == y) next
print(paste(y, "~", x))
model <- glmmTMB::glmmTMB(as.formula(
paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
),
data = df,
family = glmmTMB::beta_family()
)
# model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
# random = list(Participant=~1, Stimulus=~1),
# data = df,
# family=mgcv::betar())
pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
pred$y <- y
pred <- data_rename(pred, x, "Score")
pred$x <- x
preds <- rbind(preds, pred)
dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
}
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"
dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
ggplot(aes(x = Score, y = Predicted)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
# geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
facet_grid(y ~ x, switch = "both") +
theme_modern() +
labs(title = "Collinearity in the Stimuli Ratings") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggnewscale::new_scale_fill() +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
Effect of Delay
model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Delay, y = Real)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#795548", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
hdi(df$Delay)
## 95% HDI: [1.58, 30.31]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
##
## Delay | Participant | Stimulus | Predicted | SE | 95% CI
## ----------------------------------------------------------------
## 0.00 | | | 0.60 | 0.02 | [0.55, 0.64]
## 60.00 | | | 0.50 | 0.04 | [0.42, 0.58]
##
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)
parameters::parameters(model, effects="fixed", exponentiate=TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.48 |
0.15 |
(1.22, 1.79) |
3.94 |
< .001 |
| Delay |
0.99 |
2.89e-03 |
(0.99, 1.00) |
-2.27 |
0.023 |
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.82 |
0.11 |
(0.60, 1.04) |
7.39 |
< .001 |
| Belief (Real) |
7.73e-03 |
0.08 |
(-0.15, 0.17) |
0.09 |
0.926 |
| Belief (Fake) * Delay |
1.16e-04 |
3.03e-03 |
(-5.82e-03, 6.05e-03) |
0.04 |
0.969 |
| Belief (Real) * Delay |
-5.95e-03 |
2.62e-03 |
(-0.01, -8.18e-04) |
-2.27 |
0.023 |
Determinants of Reality
make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
# Models
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
data = df,
family = "binomial"
)
y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
# gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
# data=df,
# algorithm="sampling",
# family = "bernoulli")
# trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
# slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
# trend$Trend <- interpret_pd(slope$pd)
# trend$group <- 0
# trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
param <- parameters::parameters(m_real, effects = "fixed", keep = var)
sig1 <- data.frame(x = 0.5,
y = y_real[c(11, 31), "Predicted"] + c(0.04, -0.05),
p = c(min(param$p[c(1, 3)]), min(param$p[c(2, 4)])),
Sex = y_real[c(11, 31), "Sex"])
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
param <- parameters::parameters(m_conf, effects = "fixed", keep = var)
sig2 <- data.frame(x = 0.5,
y = y_conf[c(11, 31, 51, 71), "Predicted"] + c(0.04, -0.04, -0.04, 0.04),
p = c(min(param$p[c(1, 5)]), min(param$p[c(2, 6)]), min(param$p[c(3, 7)]), min(param$p[c(4, 8)])),
Belief = y_conf[c(11, 31, 51, 71), "Belief"],
Sex = y_conf[c(11, 32, 51, 72), "Sex"])
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
scale_fill_gradientn(colors = c("white", fill), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_point2(alpha = 0.25, size = 4, color = "black") +
geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
# geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
# geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fill, color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
var = "Familiar", fill = "#2196F3"
)
Attractiveness
parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Sex (Female) * poly(Attractive, 2)1 |
1.00 |
3.64 |
(-6.13, 8.13) |
0.28 |
0.783 |
| Sex (Male) * poly(Attractive, 2)1 |
16.37 |
4.39 |
(7.76, 24.98) |
3.73 |
< .001 |
| Sex (Female) * poly(Attractive, 2)2 |
7.77 |
3.25 |
(1.41, 14.13) |
2.40 |
0.017 |
| Sex (Male) * poly(Attractive, 2)2 |
4.61 |
5.22 |
(-5.61, 14.83) |
0.88 |
0.377 |
performance::performance(rez_at$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_at$model_belief, by_group = TRUE) |>
display()
| Participant |
0.09 |
| Stimulus |
0.09 |
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Attractive, 2)1 |
0.98 |
2.59 |
(-4.09, 6.06) |
0.38 |
0.704 |
| Belief (Real) * SexFemale * poly(Attractive, 2)1 |
2.13 |
1.87 |
(-1.54, 5.81) |
1.14 |
0.255 |
| Belief (Fake) * SexMale * poly(Attractive, 2)1 |
2.65 |
3.41 |
(-4.02, 9.33) |
0.78 |
0.436 |
| Belief (Real) * SexMale * poly(Attractive, 2)1 |
0.78 |
2.64 |
(-4.39, 5.94) |
0.30 |
0.768 |
| Belief (Fake) * SexFemale * poly(Attractive, 2)2 |
3.35 |
2.33 |
(-1.21, 7.92) |
1.44 |
0.150 |
| Belief (Real) * SexFemale * poly(Attractive, 2)2 |
4.38 |
1.74 |
(0.96, 7.79) |
2.51 |
0.012 |
| Belief (Fake) * SexMale * poly(Attractive, 2)2 |
-8.85 |
4.57 |
(-17.81, 0.11) |
-1.94 |
0.053 |
| Belief (Real) * SexMale * poly(Attractive, 2)2 |
5.11 |
2.77 |
(-0.32, 10.53) |
1.85 |
0.065 |
rez_at$p
Beauty
parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|>
display()
Fixed Effects
| Sex (Female) * poly(Beauty, 2)1 |
-1.14 |
3.68 |
(-8.36, 6.08) |
-0.31 |
0.757 |
| Sex (Male) * poly(Beauty, 2)1 |
9.54 |
4.14 |
(1.43, 17.65) |
2.31 |
0.021 |
| Sex (Female) * poly(Beauty, 2)2 |
3.43 |
3.31 |
(-3.05, 9.91) |
1.04 |
0.300 |
| Sex (Male) * poly(Beauty, 2)2 |
7.46 |
4.43 |
(-1.23, 16.14) |
1.68 |
0.092 |
performance::performance(rez_gl$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_gl$model_belief, by_group = TRUE)|>
display()
| Participant |
0.10 |
| Stimulus |
0.08 |
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Beauty, 2)1 |
-2.08 |
2.46 |
(-6.90, 2.73) |
-0.85 |
0.397 |
| Belief (Real) * SexFemale * poly(Beauty, 2)1 |
2.41 |
2.01 |
(-1.52, 6.34) |
1.20 |
0.229 |
| Belief (Fake) * SexMale * poly(Beauty, 2)1 |
-1.89 |
3.27 |
(-8.31, 4.52) |
-0.58 |
0.563 |
| Belief (Real) * SexMale * poly(Beauty, 2)1 |
2.02 |
2.38 |
(-2.65, 6.69) |
0.85 |
0.397 |
| Belief (Fake) * SexFemale * poly(Beauty, 2)2 |
6.61 |
2.36 |
(1.98, 11.24) |
2.80 |
0.005 |
| Belief (Real) * SexFemale * poly(Beauty, 2)2 |
2.66 |
1.96 |
(-1.18, 6.50) |
1.36 |
0.175 |
| Belief (Fake) * SexMale * poly(Beauty, 2)2 |
-5.50 |
3.34 |
(-12.04, 1.05) |
-1.65 |
0.100 |
| Belief (Real) * SexMale * poly(Beauty, 2)2 |
4.43 |
2.47 |
(-0.41, 9.26) |
1.79 |
0.073 |
rez_gl$p
Trustworthiness
parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Sex (Female) * poly(Trustworthy, 2)1 |
11.60 |
3.80 |
(4.15, 19.06) |
3.05 |
0.002 |
| Sex (Male) * poly(Trustworthy, 2)1 |
6.29 |
3.81 |
(-1.18, 13.76) |
1.65 |
0.099 |
| Sex (Female) * poly(Trustworthy, 2)2 |
-0.12 |
3.93 |
(-7.83, 7.59) |
-0.03 |
0.975 |
| Sex (Male) * poly(Trustworthy, 2)2 |
0.33 |
3.99 |
(-7.49, 8.16) |
0.08 |
0.933 |
performance::performance(rez_tr$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_tr$model_belief, by_group = TRUE) |>
display()
| Participant |
0.09 |
| Stimulus |
0.07 |
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)1 |
2.05 |
2.46 |
(-2.77, 6.86) |
0.83 |
0.405 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)1 |
1.27 |
2.54 |
(-3.70, 6.24) |
0.50 |
0.616 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)1 |
-3.10 |
2.81 |
(-8.61, 2.41) |
-1.10 |
0.270 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)1 |
0.43 |
2.24 |
(-3.97, 4.82) |
0.19 |
0.849 |
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)2 |
1.27 |
2.64 |
(-3.90, 6.44) |
0.48 |
0.629 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)2 |
6.47 |
2.42 |
(1.73, 11.21) |
2.68 |
0.007 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)2 |
-3.89 |
2.81 |
(-9.41, 1.63) |
-1.38 |
0.167 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)2 |
0.55 |
2.32 |
(-4.00, 5.11) |
0.24 |
0.812 |
rez_tr$p
Familiarity
parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Sex (Female) * poly(Familiar, 2)1 |
2.81 |
3.99 |
(-5.02, 10.63) |
0.70 |
0.482 |
| Sex (Male) * poly(Familiar, 2)1 |
7.95 |
5.05 |
(-1.95, 17.85) |
1.57 |
0.116 |
| Sex (Female) * poly(Familiar, 2)2 |
-2.22 |
3.70 |
(-9.47, 5.04) |
-0.60 |
0.549 |
| Sex (Male) * poly(Familiar, 2)2 |
-1.03 |
4.72 |
(-10.29, 8.23) |
-0.22 |
0.827 |
performance::performance(rez_fa$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_fa$model_belief, by_group = TRUE) |>
display()
| Participant |
0.10 |
| Stimulus |
0.07 |
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Familiar, 2)1 |
4.77 |
2.64 |
(-0.40, 9.95) |
1.81 |
0.071 |
| Belief (Real) * SexFemale * poly(Familiar, 2)1 |
-1.35 |
2.09 |
(-5.44, 2.75) |
-0.65 |
0.518 |
| Belief (Fake) * SexMale * poly(Familiar, 2)1 |
-12.67 |
3.67 |
(-19.87, -5.47) |
-3.45 |
< .001 |
| Belief (Real) * SexMale * poly(Familiar, 2)1 |
9.31 |
2.99 |
(3.45, 15.17) |
3.11 |
0.002 |
| Belief (Fake) * SexFemale * poly(Familiar, 2)2 |
0.44 |
2.46 |
(-4.37, 5.25) |
0.18 |
0.859 |
| Belief (Real) * SexFemale * poly(Familiar, 2)2 |
-0.63 |
2.13 |
(-4.81, 3.56) |
-0.29 |
0.769 |
| Belief (Fake) * SexMale * poly(Familiar, 2)2 |
8.14 |
4.15 |
(6.32e-03, 16.28) |
1.96 |
0.050 |
| Belief (Real) * SexMale * poly(Familiar, 2)2 |
-1.42 |
2.67 |
(-6.64, 3.81) |
-0.53 |
0.595 |
rez_fa$p
Inter-Individual Correlates
plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
y_real <- estimate_relation(m_real, at = c(var), length = 21)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
Belief = y_conf[c(11, 31), "Belief"])
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Data
dat <- insight::get_data(m_conf) |>
group_by(Participant, Belief) |>
data_select(c("Participant", "Belief", var, "Belief_Confidence")) |>
mean_qi(.width = 0.5) |>
mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
ggnewscale::new_scale_fill() +
stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
geom_line(data = y_real, aes(y = Predicted), size=1) +
geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
p
}
make_correlation <- function(x, y) {
cor <- correlation::correlation(x,
y,
bayesian = TRUE,
bayesian_prior = "medium.narrow",
sort = TRUE
) |>
datawizard::data_remove(c("ROPE_Percentage"))
cor$`BF (Spearman)` <- format_bf(
correlation::correlation(
x, y,
bayesian = TRUE,
ranktransform = TRUE,
bayesian_prior = "medium.narrow"
)$BF,
name = NULL, stars = TRUE
)
cor |>
arrange(desc(BF))
}
IPIP-6
f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.04 |
0.63 |
(-1.20, 1.27) |
0.06 |
0.955 |
| IPIP6 Extraversion |
3.86e-03 |
0.36 |
(-0.69, 0.70) |
0.01 |
0.991 |
| IPIP6 Conscientiousness |
2.19e-03 |
0.38 |
(-0.74, 0.75) |
5.78e-03 |
0.995 |
| IPIP6 Neuroticism |
-0.02 |
0.40 |
(-0.80, 0.77) |
-0.04 |
0.965 |
| IPIP6 Openness |
0.31 |
0.41 |
(-0.49, 1.11) |
0.76 |
0.445 |
| IPIP6 HonestyHumility |
-0.50 |
0.37 |
(-1.21, 0.22) |
-1.35 |
0.177 |
| IPIP6 Agreeableness |
0.38 |
0.46 |
(-0.51, 1.28) |
0.84 |
0.399 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
-0.36 |
0.92 |
(-2.17, 1.45) |
-0.39 |
0.695 |
| Belief (Real) |
0.20 |
0.20 |
(-0.20, 0.60) |
1.00 |
0.318 |
| Belief (Fake) * IPIP6 Extraversion |
-0.24 |
0.52 |
(-1.26, 0.78) |
-0.47 |
0.642 |
| Belief (Real) * IPIP6 Extraversion |
-0.39 |
0.52 |
(-1.41, 0.63) |
-0.76 |
0.449 |
| Belief (Fake) * IPIP6 Conscientiousness |
0.47 |
0.56 |
(-0.62, 1.55) |
0.84 |
0.403 |
| Belief (Real) * IPIP6 Conscientiousness |
0.82 |
0.55 |
(-0.26, 1.91) |
1.49 |
0.137 |
| Belief (Fake) * IPIP6 Neuroticism |
0.15 |
0.59 |
(-1.00, 1.30) |
0.26 |
0.796 |
| Belief (Real) * IPIP6 Neuroticism |
0.34 |
0.58 |
(-0.80, 1.49) |
0.59 |
0.555 |
| Belief (Fake) * IPIP6 Openness |
1.03 |
0.59 |
(-0.13, 2.20) |
1.73 |
0.083 |
| Belief (Real) * IPIP6 Openness |
0.64 |
0.59 |
(-0.52, 1.80) |
1.07 |
0.283 |
| Belief (Fake) * IPIP6 HonestyHumility |
-1.02 |
0.54 |
(-2.07, 0.03) |
-1.90 |
0.058 |
| Belief (Real) * IPIP6 HonestyHumility |
-1.69 |
0.54 |
(-2.74, -0.63) |
-3.14 |
0.002 |
| Belief (Fake) * IPIP6 Agreeableness |
1.05 |
0.67 |
(-0.26, 2.36) |
1.58 |
0.115 |
| Belief (Real) * IPIP6 Agreeableness |
1.10 |
0.67 |
(-0.21, 2.40) |
1.65 |
0.099 |
p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip
sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.38, -0.01] | 98.70%* | Beta (5.20 +- 5.20) | 3.57* | 3.55*
## Confidence_Fake | IPIP6_Openness | 0.17 | [-0.01, 0.34] | 96.20% | Beta (5.20 +- 5.20) | 1.40 | 1.12
##
## Observations: 100
Narcissism
f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
-0.07 |
0.47 |
(-0.99, 0.85) |
-0.14 |
0.887 |
| FFNI AcclaimSeeking |
0.87 |
0.46 |
(-0.04, 1.78) |
1.88 |
0.060 |
| FFNI Arrogance |
5.98e-03 |
0.41 |
(-0.80, 0.81) |
0.01 |
0.988 |
| FFNI Authoritativeness |
0.11 |
0.40 |
(-0.67, 0.89) |
0.28 |
0.782 |
| FFNI Distrust |
0.21 |
0.38 |
(-0.54, 0.95) |
0.54 |
0.590 |
| FFNI Entitlement |
-0.15 |
0.44 |
(-1.01, 0.71) |
-0.35 |
0.730 |
| FFNI Exhibitionism |
0.24 |
0.38 |
(-0.51, 0.98) |
0.62 |
0.536 |
| FFNI Exploitativeness |
-0.15 |
0.38 |
(-0.91, 0.60) |
-0.40 |
0.687 |
| FFNI GrandioseFantasies |
-0.17 |
0.34 |
(-0.83, 0.50) |
-0.49 |
0.627 |
| FFNI Indifference |
-0.13 |
0.39 |
(-0.89, 0.63) |
-0.34 |
0.733 |
| FFNI LackOfEmpathy |
0.54 |
0.40 |
(-0.25, 1.33) |
1.34 |
0.180 |
| FFNI Manipulativeness |
-0.76 |
0.43 |
(-1.60, 0.08) |
-1.78 |
0.075 |
| FFNI NeedForAdmiration |
-0.35 |
0.41 |
(-1.16, 0.46) |
-0.84 |
0.402 |
| FFNI ReactiveAnger |
0.52 |
0.35 |
(-0.16, 1.20) |
1.51 |
0.131 |
| FFNI Shame |
-0.21 |
0.45 |
(-1.09, 0.66) |
-0.48 |
0.632 |
| FFNI ThrillSeeking |
-0.09 |
0.30 |
(-0.67, 0.49) |
-0.29 |
0.768 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.55 |
0.67 |
(-0.76, 1.85) |
0.82 |
0.410 |
| Belief (Real) |
-0.78 |
0.16 |
(-1.09, -0.46) |
-4.86 |
< .001 |
| Belief (Fake) * FFNI AcclaimSeeking |
1.60 |
0.66 |
(0.30, 2.90) |
2.42 |
0.016 |
| Belief (Real) * FFNI AcclaimSeeking |
2.08 |
0.66 |
(0.79, 3.37) |
3.16 |
0.002 |
| Belief (Fake) * FFNI Arrogance |
-0.02 |
0.59 |
(-1.17, 1.14) |
-0.03 |
0.976 |
| Belief (Real) * FFNI Arrogance |
-0.39 |
0.59 |
(-1.54, 0.75) |
-0.67 |
0.501 |
| Belief (Fake) * FFNI Authoritativeness |
-1.23 |
0.57 |
(-2.35, -0.11) |
-2.15 |
0.032 |
| Belief (Real) * FFNI Authoritativeness |
-1.38 |
0.57 |
(-2.50, -0.27) |
-2.43 |
0.015 |
| Belief (Fake) * FFNI Distrust |
0.19 |
0.55 |
(-0.88, 1.26) |
0.35 |
0.727 |
| Belief (Real) * FFNI Distrust |
0.66 |
0.54 |
(-0.41, 1.73) |
1.21 |
0.226 |
| Belief (Fake) * FFNI Entitlement |
-0.32 |
0.63 |
(-1.55, 0.91) |
-0.51 |
0.612 |
| Belief (Real) * FFNI Entitlement |
0.42 |
0.63 |
(-0.81, 1.64) |
0.67 |
0.502 |
| Belief (Fake) * FFNI Exhibitionism |
0.07 |
0.55 |
(-1.00, 1.14) |
0.13 |
0.898 |
| Belief (Real) * FFNI Exhibitionism |
0.04 |
0.54 |
(-1.02, 1.11) |
0.08 |
0.937 |
| Belief (Fake) * FFNI Exploitativeness |
-0.21 |
0.55 |
(-1.29, 0.87) |
-0.38 |
0.704 |
| Belief (Real) * FFNI Exploitativeness |
-0.15 |
0.55 |
(-1.23, 0.92) |
-0.28 |
0.779 |
| Belief (Fake) * FFNI GrandioseFantasies |
0.75 |
0.49 |
(-0.21, 1.71) |
1.54 |
0.124 |
| Belief (Real) * FFNI GrandioseFantasies |
0.39 |
0.49 |
(-0.56, 1.34) |
0.80 |
0.424 |
| Belief (Fake) * FFNI Indifference |
-0.02 |
0.56 |
(-1.12, 1.07) |
-0.04 |
0.965 |
| Belief (Real) * FFNI Indifference |
-0.04 |
0.55 |
(-1.12, 1.05) |
-0.06 |
0.948 |
| Belief (Fake) * FFNI LackOfEmpathy |
-0.12 |
0.58 |
(-1.26, 1.01) |
-0.21 |
0.831 |
| Belief (Real) * FFNI LackOfEmpathy |
0.10 |
0.57 |
(-1.03, 1.23) |
0.17 |
0.863 |
| Belief (Fake) * FFNI Manipulativeness |
0.37 |
0.61 |
(-0.83, 1.57) |
0.60 |
0.550 |
| Belief (Real) * FFNI Manipulativeness |
0.25 |
0.61 |
(-0.95, 1.44) |
0.41 |
0.684 |
| Belief (Fake) * FFNI NeedForAdmiration |
-0.05 |
0.59 |
(-1.21, 1.11) |
-0.09 |
0.928 |
| Belief (Real) * FFNI NeedForAdmiration |
0.06 |
0.59 |
(-1.09, 1.22) |
0.11 |
0.913 |
| Belief (Fake) * FFNI ReactiveAnger |
0.96 |
0.50 |
(-0.02, 1.93) |
1.92 |
0.054 |
| Belief (Real) * FFNI ReactiveAnger |
0.75 |
0.49 |
(-0.22, 1.71) |
1.51 |
0.132 |
| Belief (Fake) * FFNI Shame |
-0.90 |
0.64 |
(-2.15, 0.36) |
-1.40 |
0.161 |
| Belief (Real) * FFNI Shame |
-0.69 |
0.64 |
(-1.93, 0.56) |
-1.08 |
0.280 |
| Belief (Fake) * FFNI ThrillSeeking |
-1.03 |
0.42 |
(-1.87, -0.20) |
-2.44 |
0.015 |
| Belief (Real) * FFNI ThrillSeeking |
-0.93 |
0.42 |
(-1.75, -0.10) |
-2.20 |
0.028 |
p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1
p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF9800") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2
p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_ThrillSeeking", fill = "#FF5722") + labs(x = "Narcissism (Thrill Seeking)")
p_ffni3
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | FFNI_AcclaimSeeking | 0.26 | [ 0.09, 0.44] | 99.83%** | Beta (5.20 +- 5.20) | 14.38** | 53.44***
## Confidence_Fake | FFNI_AcclaimSeeking | 0.22 | [ 0.05, 0.39] | 99.12%** | Beta (5.20 +- 5.20) | 4.52* | 6.26*
## Confidence_Real | FFNI_GrandioseFantasies | 0.22 | [ 0.03, 0.39] | 98.60%* | Beta (5.20 +- 5.20) | 4.18* | 6.07*
## n_Real | FFNI_AcclaimSeeking | 0.19 | [ 0.02, 0.37] | 97.95%* | Beta (5.20 +- 5.20) | 2.21 | 2.78
## Confidence_Fake | FFNI_GrandioseFantasies | 0.18 | [ 0.00, 0.36] | 97.05%* | Beta (5.20 +- 5.20) | 1.93 | 1.33
## Confidence_Real | FFNI_ReactiveAnger | 0.15 | [-0.03, 0.33] | 94.58% | Beta (5.20 +- 5.20) | 1.12 | 1.92
## Confidence_Fake | FFNI_Manipulativeness | 0.15 | [-0.04, 0.32] | 94.12% | Beta (5.20 +- 5.20) | 1.04 | 0.776
##
## Observations: 100
Social Anxiety
f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.34 |
0.16 |
(0.03, 0.66) |
2.15 |
0.032 |
| Social Anxiety |
0.90 |
0.51 |
(-0.10, 1.90) |
1.77 |
0.076 |
| Social Phobia |
-0.97 |
0.45 |
(-1.86, -0.08) |
-2.14 |
0.033 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.95 |
0.23 |
(0.50, 1.41) |
4.10 |
< .001 |
| Belief (Real) |
-0.21 |
0.05 |
(-0.31, -0.12) |
-4.33 |
< .001 |
| Belief (Fake) * Social Anxiety |
-0.24 |
0.79 |
(-1.79, 1.31) |
-0.30 |
0.761 |
| Belief (Real) * Social Anxiety |
0.36 |
0.79 |
(-1.19, 1.90) |
0.45 |
0.651 |
| Belief (Fake) * Social Phobia |
0.10 |
0.70 |
(-1.28, 1.48) |
0.14 |
0.886 |
| Belief (Real) * Social Phobia |
-0.32 |
0.70 |
(-1.69, 1.06) |
-0.45 |
0.650 |
p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
p_social
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)
Intolerance to Uncertainty
f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.40 |
0.27 |
(-0.14, 0.94) |
1.47 |
0.142 |
| IUS ProspectiveAnxiety |
5.24e-03 |
0.51 |
(-1.00, 1.01) |
0.01 |
0.992 |
| IUS InhibitoryAnxiety |
-0.24 |
0.39 |
(-1.00, 0.52) |
-0.62 |
0.534 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.74 |
0.40 |
(-0.05, 1.53) |
1.84 |
0.066 |
| Belief (Real) |
-0.35 |
0.09 |
(-0.52, -0.17) |
-3.91 |
< .001 |
| Belief (Fake) * IUS ProspectiveAnxiety |
0.83 |
0.77 |
(-0.68, 2.34) |
1.07 |
0.284 |
| Belief (Real) * IUS ProspectiveAnxiety |
1.10 |
0.77 |
(-0.40, 2.61) |
1.43 |
0.151 |
| Belief (Fake) * IUS InhibitoryAnxiety |
-0.78 |
0.58 |
(-1.92, 0.37) |
-1.33 |
0.183 |
| Belief (Real) * IUS InhibitoryAnxiety |
-0.74 |
0.58 |
(-1.88, 0.40) |
-1.27 |
0.204 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)
Paranoid Beliefs
f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.32 |
0.14 |
(0.04, 0.60) |
2.22 |
0.027 |
| GPTS Reference |
-0.61 |
0.44 |
(-1.47, 0.25) |
-1.39 |
0.165 |
| GPTS Persecution |
0.72 |
0.41 |
(-0.10, 1.53) |
1.73 |
0.084 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
1.05 |
0.20 |
(0.65, 1.45) |
5.16 |
< .001 |
| Belief (Real) |
-0.27 |
0.04 |
(-0.36, -0.19) |
-6.36 |
< .001 |
| Belief (Fake) * GPTS Reference |
-0.66 |
0.68 |
(-1.99, 0.66) |
-0.98 |
0.327 |
| Belief (Real) * GPTS Reference |
-0.33 |
0.68 |
(-1.66, 0.99) |
-0.49 |
0.622 |
| Belief (Fake) * GPTS Persecution |
0.35 |
0.64 |
(-0.90, 1.60) |
0.55 |
0.582 |
| Belief (Real) * GPTS Persecution |
0.35 |
0.63 |
(-0.89, 1.59) |
0.55 |
0.580 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)
AI
rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)
efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
##
## Variable | MR1 | MR2 | MR3 | Complexity | Uniqueness
## -------------------------------------------------------------------------------
## AI_4_DailyLife | 0.88 | 0.07 | 0.15 | 1.07 | 0.20
## AI_8_Exciting | 0.79 | 0.20 | 0.14 | 1.20 | 0.31
## AI_9_Applications | 0.79 | 0.09 | 0.17 | 1.12 | 0.34
## AI_7_RealisticVideos | 0.14 | 0.74 | -4.43e-03 | 1.07 | 0.43
## AI_5_ImitatingReality | 0.29 | 0.63 | 0.05 | 1.42 | 0.52
## AI_3_VideosReal | -0.15 | 0.50 | -0.12 | 1.30 | 0.71
## AI_1_RealisticImages | 0.18 | 0.49 | 0.19 | 1.56 | 0.69
## AI_2_Unethical | 0.18 | -7.70e-04 | 0.78 | 1.11 | 0.35
## AI_6_Dangerous | 0.17 | -0.12 | 0.62 | 1.23 | 0.57
## AI_10_FaceErrors | 0.02 | 0.07 | 0.25 | 1.14 | 0.93
##
## The 3 latent factors (varimax rotation) accounted for 49.60% of the total variance of the original data (MR1 = 22.50%, MR2 = 15.19%, MR3 = 11.91%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.29 |
0.09 |
(0.12, 0.47) |
3.31 |
< .001 |
| AI Enthusiasm |
7.40e-03 |
0.07 |
(-0.13, 0.15) |
0.10 |
0.919 |
| AI Realness |
0.05 |
0.08 |
(-0.11, 0.20) |
0.61 |
0.545 |
| AI Danger |
0.16 |
0.08 |
(-2.03e-03, 0.31) |
1.93 |
0.053 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.90 |
0.10 |
(0.71, 1.10) |
9.11 |
< .001 |
| Belief (Real) |
-0.15 |
0.02 |
(-0.20, -0.11) |
-6.87 |
< .001 |
| Belief (Fake) * AI Enthusiasm |
0.38 |
0.11 |
(0.18, 0.59) |
3.60 |
< .001 |
| Belief (Real) * AI Enthusiasm |
0.29 |
0.11 |
(0.08, 0.50) |
2.74 |
0.006 |
| Belief (Fake) * AI Realness |
-6.44e-03 |
0.12 |
(-0.23, 0.22) |
-0.06 |
0.956 |
| Belief (Real) * AI Realness |
0.04 |
0.12 |
(-0.18, 0.27) |
0.38 |
0.702 |
| Belief (Fake) * AI Danger |
-0.17 |
0.12 |
(-0.41, 0.06) |
-1.46 |
0.143 |
| Belief (Real) * AI Danger |
-0.09 |
0.12 |
(-0.32, 0.14) |
-0.75 |
0.453 |
p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") +
labs(x = "Enthusiasm about AI technology")
p_ai
r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.28 | [ 0.09, 0.43] | 99.83%** | Beta (5.20 +- 5.20) | 23.04** | 37.85***
## Confidence_Real | AI_Enthusiasm | 0.24 | [ 0.05, 0.41] | 99.55%** | Beta (5.20 +- 5.20) | 8.00* | 10.91**
## Confidence_Fake | AI_Danger | -0.17 | [-0.36, 0.00] | 96.47% | Beta (5.20 +- 5.20) | 1.61 | 1.01
## n_Real | AI_Danger | 0.17 | [-0.01, 0.35] | 96.53% | Beta (5.20 +- 5.20) | 1.49 | 0.943
##
## Observations: 100
Figures
fig1a <- (rez_at$p +
theme(axis.text.x = element_blank()) +
labs(x = "Attractiveness") |
rez_gl$p +
labs(x = "Beauty") +
theme(
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
) /
(rez_tr$p +
labs(x = "Trustworthiness") |
rez_fa$p +
labs(x = "Familiarity") +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank()
)
) +
plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
plot_layout(guides = "collect") &
theme(legend.position='top', legend.title = element_blank())
fig <- wrap_elements(fig1a) /
wrap_elements(
((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) +
plot_layout(guides = "collect") +
plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
param <- cor_test(dfsub, x, y, bayesian = TRUE)
# Format stat output
r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")
stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")
label <- data.frame(
x = min(dfsub[[x]], na.rm = TRUE),
y = max(dfsub[[y]], na.rm = TRUE),
label = stat
)
# Plot
dfsub |>
ggplot(aes_string(x = x, y = y)) +
geom_point2(
size = 3,
color = fillx,
# color = DVs[x],
alpha = 2 / 3
) +
geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
labs(y = ylab, x = xlab) +
geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fillx, color = "white") +
ggside::geom_ysidedensity(fill = fill, color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
}
p1 <- plot_correlation(dfsub,
x = "IPIP6_HonestyHumility",
y = "Confidence_Real",
ylab = "Confidence that the stimulus is real",
xlab = "Honesty-Humility",
fillx = "#00BCD4",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p2 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is fake",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p3 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is real",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p4 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p5 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is fake",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p6 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_GrandioseFantasies",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Grandiose Fantasies)",
fillx = "#FFC107",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
fig <- wrap_elements(fig1a) /
wrap_elements(
((p3 / p2) | (p1 / p6) | (p4 / p5)) +
plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
Social Anxiety